SGI Freeware 1999 August/SGI Freeware 1999 August.iso/dist/fw_xemacs.idb/usr/freeware/lib/xemacs-20.4/lisp/utils/text-props.el.z/text-props.el

Text File | 1998-05-21 | 25.3 KB | 587 lines

;;; text-props.el --- implements properties of characters

;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
;; Copyright (C) 1995 Amdahl Corporation.
;; Copyright (C) 1995 Ben Wing.

;; Keywords: extensions, wp, faces
;; Author: Jamie Zawinski <[e-mail]>
;; Modified: Ben Wing <[e-mail]> -- many of the Lisp functions below
;;           were completely broken.
;;
;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF.

;;; Commentary:

;;; This is a nearly complete implementation of the FSF19 text properties API.
;;; Please let me know if you notice any differences in behavior between
;;; this implementation and the FSF implementation.
;;;
;;; However, keep in mind that this interface has been implemented because it
;;; is useful.  Compatibility with code written for FSF19 is a secondary goal
;;; to having a clean and useful interface.
;;;
;;; The cruftier parts of the FSF API, such as the special handling of
;;; properties like `mouse-face', `front-sticky', and other properties whose
;;; value is a list of names of *other* properties set at this position, are
;;; not implemented.  The reason for this is that if you feel you need that
;;; kind of functionality, it's a good hint that you should be using extents
;;; instead of text properties.
;;;
;;; When should I use Text Properties, and when should I use Extents?
;;; ==================================================================
;;;
;;; If you are putting a `button' or `hyperlink' of some kind into a buffer,
;;; the most natural interface is one which deals with properties of regions
;;; with explicit endpoints that behave more-or-less like markers.  That is
;;; what `make-extent', `extent-at', and `extent-property' are for.
;;;
;;; If you are dealing with styles of text, where things do not have explicit
;;; endpoints (as is done in font-lock.el and shell-font.el) or if you want to
;;; partition a buffer (that is, change some attribute of a range from one
;;; value to another without disturbing the properties outside of that range)
;;; then an interface that deals with properties of characters may be most
;;; natural.
;;;
;;; Another way of thinking of it is, do you care where the endpoints of the
;;; region are?  If you do, then you should use extents.  If it's ok for the
;;; region to become divided, and for two regions with identical properties to
;;; be merged into one region, then you might want to use text properties.
;;;
;;; Some applications want the attributes they add to be copied by the killing
;;; and yanking commands, and some do not.  This is orthogonal to whether text
;;; properties or extents are used.  Remember that text properties are
;;; implemented in terms of extents, so anything you can do with one you can
;;; do with the other.  It's just a matter of which way of creating and
;;; managing them is most appropriate to your application.
;;;
;;; Implementation details:
;;; =======================
;;;
;;; This package uses extents with a non-nil 'text-prop property.  It assumes
;;; free reign over the endpoints of any extent with that property.  It will
;;; not alter any extent which does not have that property.
;;;
;;; Right now, the text-property functions create one extent for each distinct
;;; property; that is, if a range of text has two text-properties on it, there
;;; will be two extents.  As the set of text-properties is going to be small,
;;; this is probably not a big deal.  It would be possible to share extents.
;;;
;;; One tricky bit is that undo/kill/yank must be made to not fragment things:
;;; these extents must not be allowed to overlap.  We accomplish this by using
;;; a custom `paste-function' property on the extents.
;;;
;;; shell-font.el and font-lock.el could put-text-property to attach fonts to
;;; the buffer.  However, what these packages are interested in is the
;;; efficient extent partitioning behavior which this code exhibits, not the
;;; duplicability aspect of it.  In fact, either of these packages could be
;;; implemented by creating a one-character non-expandable extent for each
;;; character in the buffer, except that that would be extremely wasteful of
;;; memory.  (Redisplay performance would be fine, however.)
;;;
;;; If these packages were to use put-text-property to make the extents, then
;;; when one copied text from a shell buffer or a font-locked source buffer
;;; and pasted it somewhere else (a sendmail buffer, or a buffer not in
;;; font-lock mode) then the fonts would follow, and there's no easy way to
;;; get rid of them (other than pounding out a call to put-text-property by
;;; hand.)  This is annoying.  Maybe it wouldn't be so annoying if there was a
;;; more general set of commands for handling styles of text (in fact, if
;;; there were such a thing, copying the fonts would probably be exactly what
;;; one wanted) but we aren't there yet.  So these packages use the interface
;;; of `put-nonduplicable-text-property' which is the same, except that it
;;; doesn't make duplicable extents.
;;;
;;; `put-text-property' and `put-nonduplicable-text-property' don't get along:
;;; they will interfere with each other, reusing each others' extents without
;;; checking that the "duplicableness" is correct.  This is a bug, but it's
;;; one that I don't care enough to fix this right now.


;;; Code:


;; The following functions were ported to C for speed; the overhead of doing
;; this many full lisp function calls was not small.

;; #### The C functions have changed since then; the Lisp equivalents
;; should be updated.

;(defun put-text-property (start end prop value &optional buffer)
;  "Adds the given property/value to all characters in the specified region.
;The property is conceptually attached to the characters rather than the
;region.  The properties are copied when the characters are copied/pasted."
;  (put-text-property-1 start end prop value buffer t)
;  prop)
;
;(defun put-nonduplicable-text-property (start end prop value &optional buffer)
;  "Adds the given property/value to all characters in the specified region.
;The property is conceptually attached to the characters rather than the
;region, however the properties will not be copied the characters are copied."
;  (put-text-property-1 start end prop value buffer nil)
;  prop)
;
;(defun put-text-property-1 (start end prop value buffer duplicable)
;  ;; returns whether any property of a character was changed
;  (if (= start end)
;      nil
;    (save-excursion
;      (and buffer (set-buffer buffer))
;      (let ((the-extent nil)
;        (changed nil))
;    ;; prop, value, the-extent, start, end, and changed are of dynamic
;    ;; scope.  changed and the-extent are assigned.
;    (map-extents (function put-text-property-mapper) nil
;             (max 1 (1- start))
;             (min (buffer-size) (1+ end)))
;
;    ;; If we made it through the loop without reusing an extent
;    ;; (and we want there to be one) make it now.
;    (cond ((and value (not the-extent))
;           (setq the-extent (make-extent start end))
;           (set-extent-property the-extent 'text-prop prop)
;           (set-extent-property the-extent prop value)
;           (setq changed t)
;           (cond (duplicable
;              (set-extent-property the-extent 'duplicable t)
;              (set-extent-property the-extent 'paste-function
;                       'text-prop-extent-paste-function)))
;           ))
;    changed))))
;
;(defun put-text-property-mapper (e ignore)
;  ;; prop, value, the-extent, start, end, and changed are of dynamic scope.
;  ;; changed and the-extent are assigned.
;  (let ((e-start (extent-start-position e))
;    (e-end (extent-end-position e))
;    (e-val (extent-property e prop)))
;    (cond ((not (eq (extent-property e 'text-prop) prop))
;           ;; It's not for this property; do nothing.
;           nil)
;
;      ((and value
;        (not the-extent)
;        (eq value e-val))
;       ;; we want there to be an extent here at the end, and we haven't
;       ;; picked one yet, so use this one.  Extend it as necessary.
;       ;; We only reuse an extent which has an EQ value for the prop in
;       ;; question to avoid side-effecting the kill ring (that is, we
;       ;; never change the property on an extent after it has been
;       ;; created.)
;       (cond
;        ((or (/= e-start start) (/= e-end end))
;         (set-extent-endpoints e (min e-start start) (max e-end end))
;         (setq changed t)))
;       (setq the-extent e))
;
;      ;; Even if we're adding a prop, at this point, we want all other
;      ;; extents of this prop to go away (as now they overlap.)
;      ;; So the theory here is that, when we are adding a prop to a
;      ;; region that has multiple (disjoint) occurences of that prop
;      ;; in it already, we pick one of those and extend it, and remove
;      ;; the others.
;
;      ((eq e the-extent)
;       ;; just in case map-extents hits it again (does that happen?)
;       nil)
;
;      ((and (>= e-start start)
;        (<= e-end end))
;       ;; extent is contained in region; remove it.  Don't destroy or
;       ;; modify it, because we don't want to change the attributes
;       ;; pointed to by the duplicates in the kill ring.
;       (setq changed t)
;       (detach-extent e))
;
;      ((and the-extent
;        (eq value e-val)
;        (<= e-start end)
;        (>= e-end start))
;       ;; this extent overlaps, and has the same prop/value as the
;       ;; extent we've decided to reuse, so we can remove this existing
;       ;; extent as well (the whole thing, even the part outside of the
;       ;; region) and extend the-extent to cover it, resulting in the
;       ;; minimum number of extents in the buffer.
;       (cond
;        ((and (/= (extent-start-position the-extent) e-start)
;          (/= (extent-end-position the-extent) e-end))
;         (set-extent-endpoints the-extent
;                   (min (extent-start-position the-extent)
;                    e-start)
;                   (max (extent-end-position the-extent)
;                    e-end))
;         (setq changed t)))
;       (detach-extent e))
;
;      ((<= (extent-end-position e) end)
;       ;; extent begins before start but ends before end,
;       ;; so we can just decrease its end position.
;       (if (and (= (extent-start-position e) e-start)
;            (= (extent-end-position e) start))
;           nil
;         (set-extent-endpoints e e-start start)
;         (setq changed t)))
;
;      ((>= (extent-start-position e) start)
;       ;; extent ends after end but begins after start,
;       ;; so we can just increase its start position.
;       (if (and (= (extent-start-position e) end)
;            (= (extent-start-position e) e-end))
;           nil
;         (set-extent-endpoints e end e-end)
;         (setq changed t)))
;
;      (t
;       ;; Otherwise, the extent straddles the region.
;       ;; We need to split it.
;       (set-extent-endpoints e e-start start)
;       (setq e (copy-extent e))
;       (set-extent-endpoints e end e-end)
;       (setq changed t))))
;  ;; return nil to continue mapping over region.
;  nil)
;
;
;(defun text-prop-extent-paste-function (extent from to)
;  ;; Whenever a text-prop extent is pasted into a buffer (via `yank' or
;  ;; `insert' or whatever) we attach the properties to the buffer by calling
;  ;; `put-text-property' instead of by simply alowing the extent to be copied
;  ;; or re-attached.  Then we return nil, telling the C code not to attach
;  ;; it again. By handing the insertion hackery in this way, we make kill/yank
;  ;; behave consistently iwth put-text-property and not fragment the extents
;  ;; (since text-prop extents must partition, not overlap.)
;  (let* ((prop (or (extent-property extent 'text-prop)
;           (error "internal error: no text-prop on %S" extent)))
;     (val (or (extent-property extent prop)
;          (error "internal error: no text-prop %S on %S"
;             prop extent))))
;    (put-text-property from to prop val)
;    nil))
;
;(defun add-text-properties (start end props &optional buffer)
;  "Add properties to the characters from START to END.
;The third argument PROPS is a property list specifying the property values
;to add.  The optional fourth argument, OBJECT, is the buffer containing the
;text.  Returns t if any property was changed, nil otherwise."
;  (let ((changed nil))
;    (while props
;      (setq changed
;        (or (put-text-property-1 start end (car props) (car (cdr props))
;                     buffer t)
;        changed))
;      (setq props (cdr (cdr props))))
;    changed))
;
;(defun remove-text-properties (start end props &optional buffer)
;  "Remove the given properties from all characters in the specified region.
;PROPS should be a plist, but the values in that plist are ignored (treated
;as nil.)  Returns t if any property was changed, nil otherwise."
;  (let ((changed nil))
;    (while props
;      (setq changed
;        (or (put-text-property-1 start end (car props) nil buffer t)
;        changed))
;      (setq props (cdr (cdr props))))
;    changed))
;

(defun set-text-properties (start end props &optional buffer-or-string)
  "You should NEVER use this function.  It is ideologically blasphemous.
It is provided only to ease porting of broken FSF Emacs programs.
Instead, use `remove-text-properties' to remove the specific properties
you do not want.

Completely replace properties of text from START to END.
The third argument PROPS is the new property list.
The optional fourth argument, BUFFER-OR-STRING,
is the string or buffer containing the text."
  (map-extents #'(lambda (extent ignored)
           ;; #### dmoore - shouldn't this use
           ;; (extent-start-position extent)
           ;; (extent-end-position extent)
           (remove-text-properties start end
                       (list (extent-property extent
                                  'text-prop)
                         nil)
                       buffer-or-string)
           nil)
           buffer-or-string start end nil nil 'text-prop)
  (add-text-properties start end props buffer-or-string))


;;; The following functions can probably stay in lisp, since they're so simple.

;(defun get-text-property (pos prop &optional buffer)
;  "Returns the value of the PROP property at the given position."
;  (let ((e (extent-at pos buffer prop)))
;    (if e
;    (extent-property e prop)
;      nil)))

(defun extent-properties-at-1 (position buffer-or-string text-props-only)
  (let ((extent nil)
    (props nil)
    new-props)
    (while (setq extent (extent-at position buffer-or-string
                   (if text-props-only 'text-prop nil)
                   extent))
      (if text-props-only
      ;; Only return the one prop which the `text-prop' property points at.
      (let ((prop (extent-property extent 'text-prop)))
        (setq new-props (list prop (extent-property extent prop))))
    ;; Return all the properties...
    (setq new-props (extent-properties extent))
    ;; ...but!  Don't return the `begin-glyph' or `end-glyph' properties
    ;; unless the position is exactly at the appropriate endpoint.  Yeah,
    ;; this is kind of a kludge.
    ;; #### Bug, this doesn't work for end-glyphs (on end-open extents)
    ;; because we've already passed the extent with the glyph by the time
    ;; it's appropriate to return the glyph.  We could return the end
    ;; glyph one character early I guess...  But then next-property-change
    ;; would have to stop one character early as well.  It could back up
    ;; when it hit an end-glyph...
    ;; #### Another bug, if there are multiple glyphs at the same position,
    ;; we only see the first one.
    (cond ((or (extent-begin-glyph extent) (extent-end-glyph extent))
           (if (/= position (if (extent-property extent 'begin-glyph)
                    (extent-start-position extent)
                  (extent-end-position extent)))
           (let ((rest new-props)
             prev)
             (while rest
               (cond ((or (eq (car rest) 'begin-glyph)
                  (eq (car rest) 'end-glyph))
                  (if prev
                  (setcdr prev (cdr (cdr rest)))
                (setq new-props (cdr (cdr new-props))))
                  (setq rest nil)))
               (setq prev rest
                 rest (cdr rest))))))))
      (cond ((null props)
         (setq props new-props))
        (t
         (while new-props
           (or (getf props (car new-props))
           (setq props (cons (car new-props)
                     (cons (car (cdr new-props))
                       props))))
           (setq new-props (cdr (cdr new-props)))))))
    props))

(defun extent-properties-at (position &optional object)
  "Returns the properties of the character at the given position
in OBJECT (a string or buffer) by merging the properties of overlapping
extents.  The returned value is a property list, some of which may be
shared with other structures.  You must not modify it.

If POSITION is at the end of OBJECT, the value is nil.

This returns all properties on all extents.
See also `text-properties-at'."
  (extent-properties-at-1 position object nil))

(defun text-properties-at (position &optional object)
  "Returns the properties of the character at the given position
in OBJECT (a string or buffer) by merging the properties of overlapping
extents.  The returned value is a property list, some of which may be
shared with other structures.  You must not modify it.

If POSITION is at the end of OBJECT, the value is nil.

This returns only those properties added with `put-text-property'.
See also `extent-properties-at'."
  (extent-properties-at-1 position object t))

(defun text-property-any (start end prop value &optional buffer-or-string)
  "Check text from START to END to see if PROP is ever `eq' to VALUE.
If so, return the position of the first character whose PROP is `eq'
to VALUE.  Otherwise return nil.
The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
containing the text and defaults to the current buffer."
  (while (and start (< start end)
          (not (eq value (get-text-property start prop buffer-or-string))))
    (setq start (next-single-property-change start prop buffer-or-string end)))
  ;; we have to insert a special check for end due to the illogical
  ;; definition of next-single-property-change (blame FSF for this).
  (if (eq start end) nil start))

(defun text-property-not-all (start end prop value &optional buffer-or-string)
  "Check text from START to END to see if PROP is ever not `eq' to VALUE.
If so, return the position of the first character whose PROP is not
`eq' to VALUE.  Otherwise, return nil.
The optional fifth argument, BUFFER-OR-STRING, is the buffer or string
containing the text and defaults to the current buffer."
  (if (not (eq value (get-text-property start prop buffer-or-string)))
      start
    (let ((retval (next-single-property-change start prop
                           buffer-or-string end)))
      ;; we have to insert a special check for end due to the illogical
      ;; definition of previous-single-property-change (blame FSF for this).
      (if (eq retval end) nil retval))))

;; Older versions that only work sometimes (when VALUE is non-nil
;; for text-property-any, and maybe only when VALUE is nil for
;; text-property-not-all).  They might be faster in those cases,
;; but that's not obvious.

;(defun text-property-any (start end prop value &optional buffer)
;  "Check text from START to END to see if PROP is ever `eq' to VALUE.
;If so, return the position of the first character whose PROP is `eq'
;to VALUE.  Otherwise return nil."
;  ;; #### what should (text-property-any x y 'foo nil) return when there
;  ;; is no foo property between x and y?  Either t or nil seems sensible,
;  ;; since a character with a property of nil is indistinguishable from
;  ;; a character without that property set.
;  (map-extents
;   #'(lambda (e ignore)
;       (if (eq value (extent-property e prop))
;       ;; return non-nil to stop mapping
;       (max start (extent-start-position e))
;     nil))
;   nil start end buffer))
;
;(defun text-property-not-all (start end prop value &optional buffer)
;  "Check text from START to END to see if PROP is ever not `eq' to VALUE.
;If so, return the position of the first character whose PROP is not
;`eq' to VALUE.  Otherwise, return nil."
;  (let (maxend)
;    (map-extents
;     #'(lambda (e ignore)
;     ;;### no, actually, this is harder.  We need to collect all props
;     ;; for a given character, and then determine whether no extent
;     ;; contributes the given value.  Doing this without consing lots
;     ;; of lists is the tricky part.
;     (if (eq value (extent-property e prop))
;         (progn
;           (setq maxend (extent-end-position e))
;           nil)
;       (max start maxend)))
;     nil start end buffer)))

(defun next-property-change (pos &optional buffer-or-string limit)
  "Return the position of next property change.
Scans forward from POS in BUFFER-OR-STRING (defaults to the current buffer)
 until it finds a change in some text property, then returns the position of
 the change.
Returns nil if the properties remain unchanged all the way to the end.
If the value is non-nil, it is a position greater than POS, never equal.
If the optional third argument LIMIT is non-nil, don't search
 past position LIMIT; return LIMIT if nothing is found before LIMIT.
If two or more extents with conflicting non-nil values for a property overlap
 a particular character, it is undefined which value is considered to be
 the value of the property. (Note that this situation will not happen if
 you always use the text-property primitives.)"
  (let ((limit-was-nil (null limit)))
    (or limit (setq limit (if (bufferp buffer-or-string)
                  (point-max buffer-or-string)
                (length buffer-or-string))))
    (let ((value (extent-properties-at pos buffer-or-string)))
      (while
      (and (< (setq pos (next-extent-change pos buffer-or-string)) limit)
           (plists-eq value (extent-properties-at pos buffer-or-string)))))
    (if (< pos limit) pos
      (if limit-was-nil nil
    limit))))

(defun previous-property-change (pos &optional buffer-or-string limit)
  "Return the position of previous property change.
Scans backward from POS in BUFFER-OR-STRING (defaults to the current buffer)
 until it finds a change in some text property, then returns the position of
 the change.
Returns nil if the properties remain unchanged all the way to the beginning.
If the value is non-nil, it is a position less than POS, never equal.
If the optional third argument LIMIT is non-nil, don't search back
 past position LIMIT; return LIMIT if nothing is found until LIMIT.
If two or more extents with conflicting non-nil values for a property overlap
 a particular character, it is undefined which value is considered to be
 the value of the property. (Note that this situation will not happen if
 you always use the text-property primitives.)"
  (let ((limit-was-nil (null limit)))
    (or limit (setq limit (if (bufferp buffer-or-string)
                  (point-min buffer-or-string)
                0)))
    (let ((value (extent-properties-at (1- pos) buffer-or-string)))
      (while
      (and (> (setq pos (previous-extent-change pos buffer-or-string))
          limit)
           (plists-eq value (extent-properties-at (1- pos)
                              buffer-or-string)))))
    (if (> pos limit) pos
      (if limit-was-nil nil
    limit))))

(defun text-property-bounds (pos prop &optional object at-flag)
  "Return the bounds of property PROP at POS.
This returns a cons (START . END) of the largest region of text containing
POS which has a non-nil value for PROP.  The return value is nil if POS
does not have a non-nil value for PROP.  OBJECT specifies the buffer
or string to search in.  Optional arg AT-FLAG controls what \"at POS\"
means, and has the same meaning as for `extent-at'."
  (or object (setq object (current-buffer)))
  (and (get-char-property pos prop object at-flag)
       (let ((begin (if (stringp object) 0 (point-min object)))
         (end (if (stringp object) (length object) (point-max object))))
     (cons (previous-single-property-change (1+ pos) prop object begin)
           (next-single-property-change pos prop object end)))))

(defun next-text-property-bounds (count pos prop &optional object)
  "Return the COUNTth bounded property region of property PROP after POS.
If COUNT is less than zero, search backwards.  This returns a cons
\(START . END) of the COUNTth maximal region of text that begins after POS
\(starts before POS) and has a non-nil value for PROP.  If there aren't
that many regions, nil is returned.  OBJECT specifies the buffer or
string to search in."
  (or object (setq object (current-buffer)))
  (let ((begin (if (stringp object) 0 (point-min object)))
    (end (if (stringp object) (length object) (point-max object))))
    (catch 'hit-end
      (if (> count 0)
      (progn
        (while (> count 0)
          (if (>= pos end)
          (throw 'hit-end nil)
        (and (get-char-property pos prop object)
             (setq pos (next-single-property-change pos prop
                                object end)))
        (setq pos (next-single-property-change pos prop object end)))
          (setq count (1- count)))
        (and (< pos end)
         (cons pos (next-single-property-change pos prop object end))))
    (while (< count 0)
      (if (<= pos begin)
          (throw 'hit-end nil)
        (and (get-char-property (1- pos) prop object)
         (setq pos (previous-single-property-change pos prop
                                object begin)))
        (setq pos (previous-single-property-change pos prop object
                               begin)))
      (setq count (1+ count)))
    (and (> pos begin)
         (cons (previous-single-property-change pos prop object begin)
           pos))))))

;(defun detach-all-extents (&optional buffer)
;  (map-extents #'(lambda (x i) (detach-extent x) nil)
;           buffer))


(provide 'text-props)

;;; text-props.el ends here